home *** CD-ROM | disk | FTP | other *** search
/ AGA Toolkit '97 / The AGA Toolkit '97.iso / miscellaneous / science / maths / calc / source / obj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-09-07  |  15.2 KB  |  659 lines
  1. /*
  2.  * Copyright (c) 1994 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * "Object" handling primatives.
  7.  * This simply means that user-specified routines are called to perform
  8.  * the indicated operations.
  9.  */
  10.  
  11. #include "calc.h"
  12. #include "opcodes.h"
  13. #include "func.h"
  14. #include "symbol.h"
  15. #include "string.h"
  16.  
  17.  
  18. /*
  19.  * Types of values returned by calling object routines.
  20.  */
  21. #define A_VALUE    0    /* returns arbitrary value */
  22. #define A_INT    1    /* returns integer value */
  23. #define A_UNDEF    2    /* returns no value */
  24.  
  25. /*
  26.  * Error handling actions for when the function is undefined.
  27.  */
  28. #define E_NONE    0    /* no special action */
  29. #define E_PRINT    1    /* print element */
  30. #define E_CMP    2    /* compare two values */
  31. #define E_TEST    3    /* test value for nonzero */
  32. #define E_POW    4    /* call generic power routine */
  33. #define E_ONE    5    /* return number 1 */
  34. #define E_INC    6    /* increment by one */
  35. #define E_DEC    7    /* decrement by one */
  36. #define E_SQUARE 8    /* square value */
  37.  
  38.  
  39. static struct objectinfo {
  40.     short args;    /* number of arguments */
  41.     short retval;    /* type of return value */
  42.     short error;    /* special action on errors */
  43.     char *name;    /* name of function to call */
  44.     char *comment;    /* useful comment if any */
  45. } objectinfo[] = {
  46.     1, A_UNDEF, E_PRINT, "print",    "print value, default prints elements",
  47.     1, A_VALUE, E_ONE,   "one",    "multiplicative identity, default is 1",
  48.     1, A_INT,   E_TEST,  "test",    "logical test (false,true => 0,1), default tests elements",
  49.     2, A_VALUE, E_NONE,  "add",    NULL,
  50.     2, A_VALUE, E_NONE,  "sub",    NULL,
  51.     1, A_VALUE, E_NONE,  "neg",    "negative",
  52.     2, A_VALUE, E_NONE,  "mul",    NULL,
  53.     2, A_VALUE, E_NONE,  "div",    "non-integral division",
  54.     1, A_VALUE, E_NONE,  "inv",    "multiplicative inverse",
  55.     2, A_VALUE, E_NONE,  "abs",    "absolute value within given error",
  56.     1, A_VALUE, E_NONE,  "norm",    "square of absolute value",
  57.     1, A_VALUE, E_NONE,  "conj",    "conjugate",
  58.     2, A_VALUE, E_POW,   "pow",    "integer power, default does multiply, square, inverse",
  59.     1, A_INT,   E_NONE,  "sgn",    "sign of value (-1, 0, 1)",
  60.     2, A_INT,   E_CMP,   "cmp",    "equality (equal,nonequal => 0,1), default tests elements",
  61.     2, A_INT,   E_NONE,  "rel",    "inequality (less,equal,greater => -1,0,1)",
  62.     2, A_VALUE, E_NONE,  "quo",    "integer quotient",
  63.     2, A_VALUE, E_NONE,  "mod",    "remainder of division",
  64.     1, A_VALUE, E_NONE,  "int",    "integer part",
  65.     1, A_VALUE, E_NONE,  "frac",    "fractional part",
  66.     1, A_VALUE, E_INC,   "inc",    "increment, default adds 1",
  67.     1, A_VALUE, E_DEC,   "dec",    "decrement, default subtracts 1",
  68.     1, A_VALUE, E_SQUARE,"square",    "default multiplies by itself",
  69.     2, A_VALUE, E_NONE,  "scale",    "multiply by power of 2",
  70.     2, A_VALUE, E_NONE,  "shift",    "shift left by n bits (right if negative)",
  71.     2, A_VALUE, E_NONE,  "round",    "round to given number of decimal places",
  72.     2, A_VALUE, E_NONE,  "bround",    "round to given number of binary places",
  73.     3, A_VALUE, E_NONE,  "root",    "root of value within given error",
  74.     2, A_VALUE, E_NONE,  "sqrt",    "square root within given error",
  75.     0, 0, 0, NULL
  76. };
  77.  
  78.  
  79. static STRINGHEAD objectnames;    /* names of objects */
  80. static STRINGHEAD elements;    /* element names for parts of objects */
  81. static OBJECTACTIONS *objects[MAXOBJECTS]; /* table of actions for objects */
  82.  
  83.  
  84. /*
  85.  * Free list of usual small objects.
  86.  */
  87. static FREELIST    freelist = {
  88.     sizeof(OBJECT),        /* size of typical objects */
  89.     100            /* number of free objects to keep */
  90. };
  91.  
  92.  
  93. static VALUE objpowi MATH_PROTO((VALUE *vp, NUMBER *q));
  94. static BOOL objtest MATH_PROTO((OBJECT *op));
  95. static BOOL objcmp MATH_PROTO((OBJECT *op1, OBJECT *op2));
  96. static void objprint MATH_PROTO((OBJECT *op));
  97.  
  98.  
  99. /*
  100.  * Show all the routine names available for objects.
  101.  */
  102. void
  103. showobjfuncs()
  104. {
  105.     register struct objectinfo *oip;
  106.  
  107.     printf("\nThe following object routines are definable.\n");
  108.     printf("Note: xx represents the actual object type name.\n\n");
  109.     printf("Name    Args    Comments\n");
  110.     for (oip = objectinfo; oip->name; oip++) {
  111.         printf("xx_%-8s %d    %s\n", oip->name, oip->args,
  112.             oip->comment ? oip->comment : "");
  113.     }
  114.     printf("\n");
  115. }
  116.  
  117.  
  118. /*
  119.  * Call the appropriate user-defined routine to handle an object action.
  120.  * Returns the value that the routine returned.
  121.  */
  122. VALUE
  123. objcall(action, v1, v2, v3)
  124.     int action;
  125.     VALUE *v1, *v2, *v3;
  126. {
  127.     FUNC *fp;        /* function to call */
  128.     static OBJECTACTIONS *oap; /* object to call for */
  129.     struct objectinfo *oip;    /* information about action */
  130.     long index;        /* index of function (negative if undefined) */
  131.     VALUE val;        /* return value */
  132.     VALUE tmp;        /* temp value */
  133.     char name[SYMBOLSIZE+1];    /* full name of user routine to call */
  134.  
  135.     if ((unsigned)action > OBJ_MAXFUNC)
  136.         math_error("Illegal action for object call");
  137.     oip = &objectinfo[action];
  138.     if (v1->v_type == V_OBJ)
  139.         oap = v1->v_obj->o_actions;
  140.     else if (v2->v_type == V_OBJ)
  141.         oap = v2->v_obj->o_actions;
  142.     else
  143.         math_error("Object routine called with non-object");
  144.     index = oap->actions[action];
  145.     if (index == 0) {
  146.         strcpy(name, oap->name);
  147.         strcat(name, "_");
  148.         strcat(name, oip->name);
  149.         index = adduserfunc(name);
  150.         oap->actions[action] = index;
  151.     }
  152.     fp = NULL;
  153.     if (index > 0)
  154.         fp = findfunc(index);
  155.     if (fp == NULL) {
  156.         switch (oip->error) {
  157.             case E_PRINT:
  158.                 objprint(v1->v_obj);
  159.                 val.v_type = V_NULL;
  160.                 break;
  161.             case E_CMP:
  162.                 val.v_type = V_INT;
  163.                 if (v1->v_type != v2->v_type) {
  164.                     val.v_int = 1;
  165.                     return val;
  166.                 }
  167.                 val.v_int = objcmp(v1->v_obj, v2->v_obj);
  168.                 break;
  169.             case E_TEST:
  170.                 val.v_type = V_INT;
  171.                 val.v_int = objtest(v1->v_obj);
  172.                 break;
  173.             case E_POW:
  174.                 if (v2->v_type != V_NUM)
  175.                     math_error("Non-real power");
  176.                 val = objpowi(v1, v2->v_num);
  177.                 break;
  178.             case E_ONE:
  179.                 val.v_type = V_NUM;
  180.                 val.v_num = qlink(&_qone_);
  181.                 break;
  182.             case E_INC:
  183.                 tmp.v_type = V_NUM;
  184.                 tmp.v_num = &_qone_;
  185.                 val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE);
  186.                 break;
  187.             case E_DEC:
  188.                 tmp.v_type = V_NUM;
  189.                 tmp.v_num = &_qone_;
  190.                 val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE);
  191.                 break;
  192.             case E_SQUARE:
  193.                 val = objcall(OBJ_MUL, v1, v1, NULL_VALUE);
  194.                 break;
  195.             default:
  196.                 math_error("Function \"%s\" is undefined", namefunc(index));
  197.         }
  198.         return val;
  199.     }
  200.     switch (oip->args) {
  201.         case 0:
  202.             break;
  203.         case 1:
  204.             ++stack;
  205.             stack->v_addr = v1;
  206.             stack->v_type = V_ADDR;
  207.             break;
  208.         case 2:
  209.             ++stack;
  210.             stack->v_addr = v1;
  211.             stack->v_type = V_ADDR;
  212.             ++stack;
  213.             stack->v_addr = v2;
  214.             stack->v_type = V_ADDR;
  215.             break;
  216.         case 3:
  217.             ++stack;
  218.             stack->v_addr = v1;
  219.             stack->v_type = V_ADDR;
  220.             ++stack;
  221.             stack->v_addr = v2;
  222.             stack->v_type = V_ADDR;
  223.             ++stack;
  224.             stack->v_addr = v3;
  225.             stack->v_type = V_ADDR;
  226.             break;
  227.         default:
  228.             math_error("Bad number of args to calculate");
  229.     }
  230.     calculate(fp, oip->args);
  231.     switch (oip->retval) {
  232.         case A_VALUE:
  233.             return *stack--;
  234.         case A_UNDEF:
  235.             freevalue(stack--);
  236.             val.v_type = V_NULL;
  237.             break;
  238.         case A_INT:
  239.             if ((stack->v_type != V_NUM) || qisfrac(stack->v_num))
  240.                 math_error("Integer return value required");
  241.             index = qtoi(stack->v_num);
  242.             qfree(stack->v_num);
  243.             stack--;
  244.             val.v_type = V_INT;
  245.             val.v_int = index;
  246.             break;
  247.         default:
  248.             math_error("Bad object return");
  249.     }
  250.     return val;
  251. }
  252.  
  253.  
  254. /*
  255.  * Routine called to clear the cache of known undefined functions for
  256.  * the objects.  This changes negative indices back into positive ones
  257.  * so that they will all be checked for existence again.
  258.  */
  259. void
  260. objuncache()
  261. {
  262.     register int *ip;
  263.     int i, j;
  264.  
  265.     i = objectnames.h_count;
  266.     while (--i >= 0) {
  267.         ip = objects[i]->actions;
  268.         for (j = OBJ_MAXFUNC; j-- >= 0; ip++)
  269.             if (*ip < 0)
  270.                 *ip = -*ip;
  271.     }
  272. }
  273.  
  274.  
  275. /*
  276.  * Print the elements of an object in short and unambiguous format.
  277.  * This is the default routine if the user's is not defined.
  278.  */
  279. static void
  280. objprint(op)
  281.     OBJECT *op;        /* object being printed */
  282. {
  283.     int count;        /* number of elements */
  284.     int i;            /* index */
  285.  
  286.     count = op->o_actions->count;
  287.     math_fmt("obj %s {", op->o_actions->name);
  288.     for (i = 0; i < count; i++) {
  289.         if (i)
  290.             math_str(", ");
  291.         printvalue(&op->o_table[i], PRINT_SHORT | PRINT_UNAMBIG);
  292.     }
  293.     math_chr('}');
  294. }
  295.  
  296.  
  297. /*
  298.  * Test an object for being "nonzero".
  299.  * This is the default routine if the user's is not defined.
  300.  * Returns TRUE if any of the elements are "nonzero".
  301.  */
  302. static BOOL
  303. objtest(op)
  304.     OBJECT *op;
  305. {
  306.     int i;            /* loop counter */
  307.  
  308.     i = op->o_actions->count;
  309.     while (--i >= 0) {
  310.         if (testvalue(&op->o_table[i]))
  311.             return TRUE;
  312.     }
  313.     return FALSE;
  314. }
  315.  
  316.  
  317. /*
  318.  * Compare two objects for equality, returning TRUE if they differ.
  319.  * This is the default routine if the user's is not defined.
  320.  * For equality, all elements must be equal.
  321.  */
  322. static BOOL
  323. objcmp(op1, op2)
  324.     OBJECT *op1, *op2;
  325. {
  326.     int i;            /* loop counter */
  327.  
  328.     if (op1->o_actions != op2->o_actions)
  329.         return TRUE;
  330.     i = op1->o_actions->count;
  331.     while (--i >= 0) {
  332.         if (comparevalue(&op1->o_table[i], &op2->o_table[i]))
  333.             return TRUE;
  334.     }
  335.     return FALSE;
  336. }
  337.  
  338.  
  339. /*
  340.  * Raise an object to an integral power.
  341.  * This is the default routine if the user's is not defined.
  342.  * Negative powers mean the positive power of the inverse.
  343.  * Zero means the multiplicative identity.
  344.  */
  345. static VALUE
  346. objpowi(vp, q)
  347.     VALUE *vp;        /* value to be powered */
  348.     NUMBER *q;        /* power to raise number to */
  349. {
  350.     VALUE res, tmp;
  351.     long power;        /* power to raise to */
  352.     unsigned long bit;    /* current bit value */
  353.  
  354.     if (qisfrac(q))
  355.         math_error("Raising object to non-integral power");
  356.     if (zge31b(q->num))
  357.         math_error("Raising object to very large power");
  358.     power = (zistiny(q->num) ? z1tol(q->num) : z2tol(q->num));
  359.     if (qisneg(q))
  360.         power = -power;
  361.     /*
  362.      * Handle some low powers specially
  363.      */
  364.     if ((power <= 2) && (power >= -2)) {
  365.         switch ((int) power) {
  366.             case 0:
  367.                 return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
  368.             case 1:
  369.                 res.v_obj = objcopy(vp->v_obj);
  370.                 res.v_type = V_OBJ;
  371.                 return res;
  372.             case -1:
  373.                 return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
  374.             case 2:
  375.                 return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
  376.         }
  377.     }
  378.     if (power < 0)
  379.         power = -power;
  380.     /*
  381.      * Compute the power by squaring and multiplying.
  382.      * This uses the left to right method of power raising.
  383.      */
  384.     bit = TOPFULL;
  385.     while ((bit & power) == 0)
  386.         bit >>= 1L;
  387.     bit >>= 1L;
  388.     res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
  389.     if (bit & power) {
  390.         tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
  391.         objfree(res.v_obj);
  392.         res = tmp;
  393.     }
  394.     bit >>= 1L;
  395.     while (bit) {
  396.         tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
  397.         objfree(res.v_obj);
  398.         res = tmp;
  399.         if (bit & power) {
  400.             tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
  401.             objfree(res.v_obj);
  402.             res = tmp;
  403.         }
  404.         bit >>= 1L;
  405.     }
  406.     if (qisneg(q)) {
  407.         tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
  408.         objfree(res.v_obj);
  409.         return tmp;
  410.     }
  411.     return res;
  412. }
  413.  
  414.  
  415. /*
  416.  * Define a (possibly) new class of objects.
  417.  * The list of indexes for the element names is also specified here,
  418.  * and the number of elements defined for the object.
  419.  */
  420. void
  421. defineobject(name, indices, count)
  422.     char *name;        /* name of object type */
  423.     int indices[];        /* table of indices for elements */
  424.     int count;
  425. {
  426.     OBJECTACTIONS *oap;    /* object definition structure */
  427.     STRINGHEAD *hp;
  428.     int index;
  429.  
  430.     hp = &objectnames;
  431.     if (hp->h_list == NULL)
  432.         initstr(hp);
  433.     index = findstr(hp, name);
  434.     if (index >= 0) {
  435.         /*
  436.          * Object is already defined.  Give an error unless this
  437.          * new definition is exactly the same as the old one.
  438.          */
  439.         oap = objects[index];
  440.         if (oap->count == count) {
  441.             for (index = 0; ; index++) {
  442.                 if (index >= count)
  443.                     return;
  444.                 if (oap->elements[index] != indices[index])
  445.                     break;
  446.             }
  447.         }
  448.         math_error("Object type \"%s\" is already defined", name);
  449.     }
  450.  
  451.     if (hp->h_count >= MAXOBJECTS)
  452.         math_error("Too many object types in use");
  453.     oap = (OBJECTACTIONS *) malloc(objectactionsize(count));
  454.     if (oap)
  455.         name = addstr(hp, name);
  456.     if ((oap == NULL) || (name == NULL))
  457.         math_error("Cannot allocate object type");
  458.     oap->name = name;
  459.     oap->count = count;
  460.     for (index = OBJ_MAXFUNC; index >= 0; index--)
  461.         oap->actions[index] = 0;
  462.     for (index = 0; index < count; index++)
  463.         oap->elements[index] = indices[index];
  464.     index = findstr(hp, name);
  465.     objects[index] = oap;
  466.     return;
  467. }
  468.  
  469.  
  470. /*
  471.  * Check an object name to see if it is currently defined.
  472.  * If so, the index for the object type is returned.
  473.  * If the object name is currently unknown, then -1 is returned.
  474.  */
  475. int
  476. checkobject(name)
  477.     char *name;
  478. {
  479.     STRINGHEAD *hp;
  480.  
  481.     hp = &objectnames;
  482.     if (hp->h_list == NULL)
  483.         return -1;
  484.     return findstr(hp, name);
  485. }
  486.  
  487.  
  488. /*
  489.  * Define a (possibly) new element name for an object.
  490.  * Returns an index which identifies the element name.
  491.  */
  492. int
  493. addelement(name)
  494.     char *name;
  495. {
  496.     STRINGHEAD *hp;
  497.     int index;
  498.  
  499.     hp = &elements;
  500.     if (hp->h_list == NULL)
  501.         initstr(hp);
  502.     index = findstr(hp, name);
  503.     if (index >= 0)
  504.         return index;
  505.     if (addstr(hp, name) == NULL)
  506.         math_error("Cannot allocate element name");
  507.     return findstr(hp, name);
  508. }
  509.  
  510.  
  511. /*
  512.  * Return the index which identifies an element name.
  513.  * Returns minus one if the element name is unknown.
  514.  */
  515. int
  516. findelement(name)
  517.     char *name;        /* element name */
  518. {
  519.     if (elements.h_list == NULL)
  520.         return -1;
  521.     return findstr(&elements, name);
  522. }
  523.  
  524.  
  525. /*
  526.  * Return the value table offset to be used for an object element name.
  527.  * This converts the element index from the element table into an offset
  528.  * into the object value array.  Returns -1 if the element index is unknown.
  529.  */
  530. int
  531. objoffset(op, index)
  532.     OBJECT *op;
  533.     long index;
  534. {
  535.     register OBJECTACTIONS *oap;
  536.     int offset;            /* offset into value array */
  537.  
  538.     oap = op->o_actions;
  539.     for (offset = oap->count - 1; offset >= 0; offset--) {
  540.         if (oap->elements[offset] == index)
  541.             return offset;
  542.     }
  543.     return -1;
  544. }
  545.  
  546.  
  547. /*
  548.  * Allocate a new object structure with the specified index.
  549.  */
  550. OBJECT *
  551. objalloc(index)
  552.     long index;
  553. {
  554.     OBJECTACTIONS *oap;
  555.     OBJECT *op;
  556.     VALUE *vp;
  557.     int i;
  558.  
  559.     if ((unsigned) index >= MAXOBJECTS)
  560.         math_error("Allocating bad object index");
  561.     oap = objects[index];
  562.     if (oap == NULL)
  563.         math_error("Object type not defined");
  564.     i = oap->count;
  565.     if (i < USUAL_ELEMENTS)
  566.         i = USUAL_ELEMENTS;
  567.     if (i == USUAL_ELEMENTS)
  568.         op = (OBJECT *) allocitem(&freelist);
  569.     else
  570.         op = (OBJECT *) malloc(objectsize(i));
  571.     if (op == NULL)
  572.         math_error("Cannot allocate object");
  573.     op->o_actions = oap;
  574.     vp = op->o_table;
  575.     for (i = oap->count; i-- > 0; vp++) {
  576.         vp->v_num = qlink(&_qzero_);
  577.         vp->v_type = V_NUM;
  578.     }
  579.     return op;
  580. }
  581.  
  582.  
  583. /*
  584.  * Free an object structure.
  585.  */
  586. void
  587. objfree(op)
  588.     register OBJECT *op;
  589. {
  590.     VALUE *vp;
  591.     int i;
  592.  
  593.     vp = op->o_table;
  594.     for (i = op->o_actions->count; i-- > 0; vp++) {
  595.         if (vp->v_type == V_NUM) {
  596.             qfree(vp->v_num);
  597.         } else
  598.             freevalue(vp);
  599.     }
  600.     if (op->o_actions->count <= USUAL_ELEMENTS)
  601.         freeitem(&freelist, (FREEITEM *) op);
  602.     else
  603.         free((char *) op);
  604. }
  605.  
  606.  
  607. /*
  608.  * Copy an object value
  609.  */
  610. OBJECT *
  611. objcopy(op)
  612.     OBJECT *op;
  613. {
  614.     VALUE *v1, *v2;
  615.     OBJECT *np;
  616.     int i;
  617.  
  618.     i = op->o_actions->count;
  619.     if (i < USUAL_ELEMENTS)
  620.         i = USUAL_ELEMENTS;
  621.     if (i == USUAL_ELEMENTS)
  622.         np = (OBJECT *) allocitem(&freelist);
  623.     else
  624.         np = (OBJECT *) malloc(objectsize(i));
  625.     if (np == NULL)
  626.         math_error("Cannot allocate object");
  627.     np->o_actions = op->o_actions;
  628.     v1 = op->o_table;
  629.     v2 = np->o_table;
  630.     for (i = op->o_actions->count; i-- > 0; v1++, v2++) {
  631.         if (v1->v_type == V_NUM) {
  632.             v2->v_num = qlink(v1->v_num);
  633.             v2->v_type = V_NUM;
  634.         } else
  635.             copyvalue(v1, v2);
  636.     }
  637.     return np;
  638. }
  639.  
  640.  
  641. /*
  642.  * Return a trivial hash value for an object.
  643.  */
  644. HASH
  645. objhash(op)
  646.     OBJECT *op;
  647. {
  648.     HASH hash;
  649.     int i;
  650.  
  651.     hash = 0;
  652.     i = op->o_actions->count;
  653.     while (--i >= 0)
  654.         hash = hash * 4000037 + hashvalue(&op->o_table[i]);
  655.     return hash;
  656. }
  657.  
  658. /* END CODE */
  659.